Situacion Problematica
Problema Cientifico
- Objetivos
  - General
  - Específicos
Conjunto de datos
- Leyendo Datos
- Union y Limpieza de Datos
  - Subject-Card1-Card2
Analisis Exploratorio
- Exploraci?n de variables y eliminacion de outlier
- Desecho de Variables
Analis?s de Componentes Principales
- Matriz de Correlaci?n
Cluster
- Diagrama de Codo
- Creacion de Cluster
- Analisis Express
- Genero
  - Grupo 1
  - Grupo 2
  - Grupo 3
  - Grupo 4
- Altura-Edad
  - Grupo 1
  - Grupo 2
  - Grupo 3
  - Grupo 4
- Hand Grip-Edad
  - Grupo 1
  - Grupo 2
  - Grupo 3
  - Grupo 4
- Peso-Edad
  - Grupo 1
  - Grupo 2
  - Grupo 3
  - Grupo 4
- Conclusion de Cluster
Prediciendo Peso

Situacion Problematica

No se ha buscado la relacion entre habilidades cognitivas, crecimiento y salud de los huesos utilizando los datos del estudio longitudinal de la UVG y los estudios que se han realizado con datos parecidos no han sido bien investigados en paises de bajos y medianos ingresos.

Los datos utilizados para este analisis son el producto de un estudio longitudinal dise?ado por el Dr. Barry Bogin hace mas de 50 años en conjunto con el Colegio Americano de Guatemala. Ellos se propusieron a colectar datos longitudinalmente de estudiantes de todos los a?os y darle seguimiento a su crecimiento de forma anual hasta el momento en el que completaban sus estudios de bachillerato. El estudio se expandio a 6 colegios m?s a lo largo de los años y se cuenta con datos de peso, talla, IQ, pruebas de lectura y masa osea para registros comenzando en el a?o 1953.

Esta base de datos pertenece a la fundaci?n Bill and Melinda Gates, los cuales donaron los fondos necesarios para digitalizarla.

Problema Cientifico

Los niños del dataset escogido tienen una estatura menor a los niños de otros paises para los mismos grupos etarios. Se está buscando formas de extrapolar los datos de la base de datos a nivel nacional para poder utilizar macroindicadores para buscar una razón por la cual los niños de Guatemala son más pequeños.

Objetivos

General

Diseñar un modelo predictivo para estatura y/o peso basado en los datos disponibles del estudio longitudinal del Dr. Bogin para poder tener datos representativos de la realidad nacional.

Específicos

Realizar un analisis exploratorio de los datos para determinar la forma apropiada de diseñar el modelo predictivo sugerido.
Diseñar un modelo predictivo para peso y/o talla
Probar distintos modelos predictivos diferentes para compararlos entre sí y escoger el mejor.
Realizar una limpieza general de los Datos a utilizar.

Conjunto de datos

Leyendo Datos

Subjects: Informacion personal de cada sujeto de prueba.
Card1: Informacion fisiol?gica de los sujetos.
Card2: Informacion fisiol?gica complementaria.

subjects = as.data.table(read_xlsx(path = "data/1-Subjects sex_ID_school_DOB.xlsx"))
card1 = as.data.table(read_xlsx("data/4-Card1.xlsx"))
card2 = as.data.table(read_xlsx("data/5-Card2.xlsx"))

Variables desechadas

En las tres bases de datos existen registros de control de digitalizacion como.

entering date: Fecha en la que los datos fueron digitalizados.
User : Usuario que digitaliz? el dato.

Estas variables, por ser solo de control, junto a Repetition en Card1 y Card2, que no esta presente en casi todo el conjunto de datos, seran desechadas.

Subject

En Subjects podemos encontrar las siguientes variables personales de cada sujeto de estudio.

ID: Identificador personal para cada persona involucrada en el set de datos.
DOB: Fecha de nacimiento de la persona.
DOB decimal: A?o de nacimiento de la persona en representacion decimal.
Sex: Sexo de la persona.
IdSchool 1: Identificador del colegio al que asisti? la persona.
IdSchool 2: Valor booleano que representa si el sujeto ya no estudia en el colegio representado en IdSchool 1

Card1

En Card1 podemos encontrar las siguientes caracteristicas fisiologicas de los sujetos de observacion.

yearCard1: A?o en el que se recopilaron los datos.
gradeCard1: Grado escolar al que pertenec?a la persona.
Height: Altura de la persona en centimetros.
Weight: Peso de la persona en kg.
Hand grip: Fuerza de la mano calculado en kg.
Dental: Dentici?n piezas del sujeto. N?mero de piezas permanentes eruptadas.

Card2

En Card2 podemos encontrar las siguientes caracteristicas fisiologicas de los sujetos de observacion.

yearCard2: A?o en el que se recopilaron los datos.
grade Card 2: Grado escolar al que pertenec?a la persona.
UAC1: Circunferencia Tricep 1
UAC2: Circunferencia Tricep 2
TST1: Pliegue Cut?neo Tricep 1
TST2: Pliegue Cut?neo Tricep 2
SSF1: Pliegue Cut?neo Subescapular 1
SSF2: Pliegue Cut?neo Subescapular 2

Union y Limpieza de Datos

Subject-Card1-Card2

mainData = subjects
c1 = card1
c2 = card2 

colnames(mainData)[1] <- "Id"
colnames(c1)[2] <- "date" 
colnames(c2)[2] <- "date"

cards <- merge(c1, c2, by = c("Id", "date"))
completeData <- merge(mainData, cards, by = "Id")
completeData$age <- round(completeData$date - completeData$`DOB decimal`, 0)

Analisis Exploratorio

##Card1-Card2

Exploraci?n de variables y eliminacion de outlier

Frecuencia de edades

ggplot(completeData, aes(x = age)) +
  geom_bar() +
  labs(x = "Edad", y = "Frecuencia")

Altura por Edad

ggplot(completeData, aes(group = age, x = age, y = Height)) +
  geom_boxplot() +
  labs(x = "Edad", y = "Altura (cm)")

Las alturas de m?s de 250 cm no tienen sentido. Adem?s, las edades mayores a 22 a?os tienen muy pocos datos. Se decidi? removerlos:

completeData <- completeData %>% 
  filter(Height < 250) %>% 
  filter(age < 23)

Sin outliers

ggplot(completeData, aes(group = age, x = age, y = Height)) +
  geom_boxplot() +
  labs(x = "Edad", y = "Altura (cm)")

Pesos por Edades

ggplot(completeData, aes(group = age, x = age, y = Weight)) +
  geom_boxplot() +
  labs(x = "Edad", y = "Peso (kg)")

Pesos mayores a 200 kg no tienen sentidos. Se decidi? eliminarlos:

completeData <- completeData %>% 
  filter(Weight < 200)

Sin outliers

ggplot(completeData, aes(group = age, x = age, y = Weight)) +
  geom_boxplot() +
  labs(x = "Edad", y = "Peso (kg)")

Regresion Lineal Peso-Altura

for(i in 4:22){
  temp <- completeData %>% 
    filter(age == i)
  
  print(ggplot(temp, aes(x = Weight, y = Height)) + geom_point() + 
           labs(x = "Peso (kg)", y = "Altura (cm)", title = paste(i, " anos")) +
    geom_smooth(method = lm, se = F))
}

Solo existen 4 datos para mediciones con cuatro y veintidos a?os de edad. Se eliminar?n:

completeData <- completeData %>% 
  filter(age > 4) %>% 
  filter(age < 22)

Altura-Dientes

ggplot(completeData, aes(group = Dental, x = Dental, y = Height)) +
  geom_boxplot() +
  labs(x = "N?mero de dientes", y = "Altura (cm)")

No tiene sentido que hayan ni?os tan altos sin dientes permanentes “erupcionados”. Seg?n la Asociaci?n Dental de Am?rica, se espera que a partir de los 6-7 a?os por lo menos se hayan desarrollado los incisivos centrales. Probablemente esos “0”s signifiquen que no fue registrado el dato. Para comprobar cu?ntos registros de ni?os mayores a?os no tienen dientes permanentes “erupcionados”:

paste(round((nrow(filter(completeData, age > 7 & Dental == 0)) 
             / nrow(completeData) * 100),2), "%")

## [1] "62.46 %"

M?s del 60% de los datos no tienen ese registro, por lo que no se utilizar? esta columna.

completeData <- completeData %>% 
  mutate(Dental = NULL)

IdSchool | Repetition | RepetitionCard1

IdSchool2, que indica si se cambiaron de colegio parece tener muchos NAs. Chequear:

paste(round(nrow(filter(completeData, is.na(`IdSchool 2`))) / 
              nrow(completeData) * 100, 2), "%")

## [1] "99.86 %"

Casi el 100% de los registros no poseen esta informaci?n. Se eliminar? esta columna. Adem?s, se eliminar?n las columnas Repetition y RepetitionCard1 ya que estas proveen poca informaci?n acerca de la altura. Es m?s, los alumnos repitentes podr?an distorsionar las predicciones.

completeData <- completeData %>% 
  mutate(`IdSchool 2` = NULL) %>% 
  mutate(Repetition = NULL) %>% 
  mutate(RepetitionCard1 = NULL)

Fuerza de Agarre (Hand grip)

Visualizar los datos de pruebas de fuerza de agarre:

ggplot(completeData, aes(y = `Hand grip`, x = age, group = age)) +
  geom_boxplot() +
  labs(y = "fuerza de agarre (kg)", x = "Edad (a?os)")

No existen registros de pruebas de fuerza de agarre en los que se superen los 100 kg de fuerza de agarre, por lo que se eliminar?n los outliers y se vuelve a graficar:

completeData <- completeData %>% 
  filter(`Hand grip` < 100)

Sin outliers

ggplot(completeData, aes(y = `Hand grip`, x = age, group = age)) +
  geom_boxplot() +
  labs(y = "fuerza de agarre (kg)", x = "Edad (a?os)")

Fuerza de Agarre-Edad

for(i in 5:21){
  temp <- completeData %>% 
    filter(age == i)
  
  print(ggplot(temp, aes(x = `Hand grip`)) + 
          geom_bar() + 
           labs(y = "Frecuencia", 
                x = "fuerza de agarre (kg)", 
                title = paste(i, " a?os")
                )
  )
}

La fuerza de agarre presenta una distribuci?n aparentemente normal desde los 5 hasta los 14 a?os. Sin embargo, a partir de los 15 a?os y sobre todo entre los 17 y 19 a?os, se pueden observar claramente dos distribuciones que se traslapan. Esto indica que en estas edades la diferencia de fuerza de agarre es mucho m?s marcada entre dos grupos que no se encuentran diferenciados.

Probando agrupar por sexo:

## Warning: position_stack requires non-overlapping x intervals

## Warning: position_stack requires non-overlapping x intervals

## Warning: position_stack requires non-overlapping x intervals

## Warning: position_stack requires non-overlapping x intervals

## Warning: position_stack requires non-overlapping x intervals

## Warning: position_stack requires non-overlapping x intervals

## Warning: position_stack requires non-overlapping x intervals

## Warning: position_stack requires non-overlapping x intervals

Se observa claramente que a partir de los 15 a?os, los hombres tienen una distribuci?n normal (aparentemente) con una media de fuerza de agarre mayor al de las mujeres. Por lo tanto, debemos considerarlos como dos grupos claramente distintos a partir de esa edad.

Desecho de Variables

Se eliminar?n otras variables poco ?tiles como entering date, entering data y User. Tambi?n se eliminar?n DOB y DOB decimal debido a que ya se calcul? la edad en cada registro.

completeData <- completeData %>% 
  mutate(`entering date` = NULL) %>% 
  mutate(`entering data` = NULL) %>% 
  mutate(User.x = NULL) %>% 
  mutate(User.y = NULL) %>% 
  mutate(DOB = NULL) %>% 
  mutate(`DOB decimal` = NULL)

Analis?s de Componentes Principales

Se evalur? la factibilidad de realizar un an?lisis de componentes principales utilizando la base de datos unificada del estudio.

pafDatos<-paf(as.matrix(completeData[,5:16]))
pafDatos$KMO

## [1] 0.85819

pafDatos$Bartlett

## [1] 2421648

summary(pafDatos)

## $KMO
## [1] 0.85819
## 
## $MSA
##                  MSA
## gradeCard1   0.83601
## Height       0.92160
## Weight       0.90312
## Hand grip    0.93608
## grade Card 2 0.83729
## UAC1 cm      0.80366
## UAC2 cm      0.80384
## TST1 mm      0.79716
## TST2 mm      0.79823
## SSF1 mm      0.82861
## SSF2 mm      0.82803
## age          0.97768
## 
## $Bartlett
## [1] 2421648
## 
## $Communalities
##              Initial Communalities Final Extraction
## gradeCard1                 0.98864          0.86971
## Height                     0.91943          0.89380
## Weight                     0.94777          0.91474
## Hand grip                  0.87237          0.81604
## grade Card 2               0.98820          0.86287
## UAC1 cm                    0.99593          0.57536
## UAC2 cm                    0.99593          0.57580
## TST1 mm                    0.95257          0.87040
## TST2 mm                    0.95345          0.87526
## SSF1 mm                    0.96473          0.85979
## SSF2 mm                    0.96527          0.86265
## age                        0.87779          0.87569
## 
## $Factor.Loadings
##                 [,1]      [,2]
## gradeCard1   0.83186  0.421571
## Height       0.86609  0.379059
## Weight       0.94768  0.128994
## Hand grip    0.79659  0.426004
## grade Card 2 0.82894  0.419198
## UAC1 cm      0.75193 -0.099771
## UAC2 cm      0.75237 -0.098677
## TST1 mm      0.62373 -0.693797
## TST2 mm      0.62838 -0.693102
## SSF1 mm      0.74180 -0.556351
## SSF2 mm      0.74499 -0.554659
## age          0.83283  0.426710
## 
## $RMS
## [1] 0.066734

cortest.bartlett(completeData[,5:16])

## $chisq
## [1] 2421648
## 
## $p.value
## [1] 0
## 
## $df
## [1] 66

Como se puede observar se obtuvo un KMO de 0.86 y un coeficiente de Bartlett muy elevado 2421661 por lo que parece que un analisis de componentes principales es una buena idea. Considerando que el valor P indicado es de 0.

Matriz de Correlaci?n

kable(cor(completeData[,5:16],use = "pairwise.complete.obs"))

	gradeCard1	Height	Weight	Hand grip	grade Card 2	UAC1 cm	UAC2 cm	TST1 mm	TST2 mm	SSF1 mm	SSF2 mm	age
gradeCard1	1.00000	0.85641	0.80226	0.79473	0.99407	0.52631	0.52727	0.25662	0.26096	0.38687	0.39030	0.91093
Height	0.85641	1.00000	0.91493	0.89282	0.85280	0.58126	0.58223	0.29189	0.29666	0.42382	0.42748	0.88920
Weight	0.80226	0.91493	1.00000	0.87762	0.79880	0.67957	0.68008	0.49164	0.49593	0.65189	0.65519	0.82843
Hand grip	0.79473	0.89282	0.87762	1.00000	0.79095	0.56448	0.56525	0.17862	0.18268	0.36034	0.36341	0.82868
grade Card 2	0.99407	0.85280	0.79880	0.79095	1.00000	0.52445	0.52540	0.25646	0.26080	0.38606	0.38955	0.90778
UAC1 cm	0.52631	0.58126	0.67957	0.56448	0.52445	1.00000	0.99796	0.49499	0.49778	0.55661	0.55874	0.53125
UAC2 cm	0.52727	0.58223	0.68008	0.56525	0.52540	0.99796	1.00000	0.49431	0.49728	0.55615	0.55846	0.53227
TST1 mm	0.25662	0.29189	0.49164	0.17862	0.25646	0.49499	0.49431	1.00000	0.97528	0.81732	0.81671	0.23912
TST2 mm	0.26096	0.29666	0.49593	0.18268	0.26080	0.49778	0.49728	0.97528	1.00000	0.81943	0.82168	0.24343
SSF1 mm	0.38687	0.42382	0.65189	0.36034	0.38606	0.55661	0.55615	0.81732	0.81943	1.00000	0.98156	0.39275
SSF2 mm	0.39030	0.42748	0.65519	0.36341	0.38955	0.55874	0.55846	0.81671	0.82168	0.98156	1.00000	0.39630
age	0.91093	0.88920	0.82843	0.82868	0.90778	0.53125	0.53227	0.23912	0.24343	0.39275	0.39630	1.00000

En la matriz de correlaci?n observamos que algunas variables se encuentran relacionadas por lo que se proceder? a realizar el analisis de componentes principales para intentar reducir el dataset.

compPrinc<-prcomp(completeData[,5:16], scale = T)
compPrinc

## Standard deviations (1, .., p=12):
##  [1] 2.747921 1.616220 0.945791 0.616499 0.530070 0.331693 0.288965
##  [8] 0.191409 0.158107 0.134577 0.076768 0.045138
## 
## Rotation (n x k) = (12 x 12):
##                   PC1       PC2         PC3       PC4       PC5        PC6
## gradeCard1   -0.30401 -0.269759 -0.17414549  0.386405 -0.234315  0.2859950
## Height       -0.31565 -0.240520 -0.08540084 -0.166256  0.327864 -0.3033746
## Weight       -0.34461 -0.082917 -0.06779067 -0.325564  0.198734  0.0307808
## Hand grip    -0.29344 -0.277911  0.00035571 -0.438306  0.308140  0.4495349
## grade Card 2 -0.30322 -0.268947 -0.17530638  0.394565 -0.241555  0.3019985
## UAC1 cm      -0.28730  0.071510  0.63308014  0.081038 -0.067667 -0.0191125
## UAC2 cm      -0.28745  0.070725  0.63274012  0.081285 -0.067745 -0.0204074
## TST1 mm      -0.22839  0.437747 -0.14812711  0.290244  0.381407  0.0295550
## TST2 mm      -0.22994  0.436489 -0.14862260  0.285589  0.373284  0.0265191
## SSF1 mm      -0.27188  0.351776 -0.17275539 -0.296548 -0.416570 -0.0088605
## SSF2 mm      -0.27294  0.350309 -0.17242592 -0.293925 -0.412166 -0.0111611
## age          -0.30418 -0.272423 -0.14931864  0.126313 -0.086110 -0.7275829
##                     PC7         PC8         PC9       PC10        PC11
## gradeCard1    0.0924795  0.00370190 -0.00112969  0.0021799  7.1407e-01
## Height        0.6006008 -0.49705760 -0.01485158 -0.0059114 -2.2324e-03
## Weight        0.2626976  0.80868119  0.01339779  0.0130978 -3.7465e-03
## Hand grip    -0.5342205 -0.24920449  0.00010806 -0.0041129 -1.0930e-03
## grade Card 2  0.0989190 -0.00010443 -0.00049563 -0.0020808 -6.9998e-01
## UAC1 cm       0.0049942 -0.01289632 -0.00370285  0.0029086 -1.8120e-04
## UAC2 cm       0.0059030 -0.01471850  0.00258083 -0.0029117  2.0805e-04
## TST1 mm      -0.0955495  0.00196594 -0.68737431 -0.1485430  1.2609e-06
## TST2 mm      -0.0846200 -0.02993082  0.69407030  0.1520369 -1.7148e-04
## SSF1 mm       0.0144062 -0.12416804 -0.15581519  0.6863130 -1.2243e-03
## SSF2 mm       0.0174727 -0.10826089  0.14516225 -0.6953701  3.0080e-03
## age          -0.4996768  0.09182093  0.00324789  0.0022928 -9.7970e-03
##                     PC12
## gradeCard1   -2.7952e-04
## Height       -1.4022e-03
## Weight        8.6583e-04
## Hand grip     3.2516e-04
## grade Card 2  9.3384e-05
## UAC1 cm      -7.0699e-01
## UAC2 cm       7.0720e-01
## TST1 mm       2.6874e-03
## TST2 mm      -2.2652e-03
## SSF1 mm       3.4936e-03
## SSF2 mm      -3.5161e-03
## age          -4.7521e-04

summary(compPrinc)

## Importance of components:
##                          PC1   PC2    PC3    PC4    PC5     PC6     PC7
## Standard deviation     2.748 1.616 0.9458 0.6165 0.5301 0.33169 0.28897
## Proportion of Variance 0.629 0.218 0.0745 0.0317 0.0234 0.00917 0.00696
## Cumulative Proportion  0.629 0.847 0.9215 0.9532 0.9766 0.98574 0.99269
##                            PC8     PC9    PC10    PC11    PC12
## Standard deviation     0.19141 0.15811 0.13458 0.07677 0.04514
## Proportion of Variance 0.00305 0.00208 0.00151 0.00049 0.00017
## Cumulative Proportion  0.99575 0.99783 0.99934 0.99983 1.00000

compPrincPCA<-PCA(completeData[,5:16],ncp=ncol(completeData[,5:16]), scale.unit = T)

Al realizar el análisis de componentes principales observamos que realmente no se redujo el dataset de ninguna forma al evaluar los componentes principales. Los indicadores utilizados como KMO y Bartlett parecen indicar que se puede realizar un análisis de componentes principales pero como se puede observar en las comunalidades la mayoría de las variables seleccionadas para el análisis del PCA explican su variabilidad correctamente. Por lo que realizar un análisis de componentes principales solo reordena las variables de la más variable a la menos variable. Esto es innecesario por lo que no se realizará análisis de componentes principales y se trabajará con las variables del set de datos tal y como están.

Cluster

Ahora que hemos unido ambos Cards, eliminado outliers y desechado variables innecesari, nuestro conjunto de datos est? listo para entrar a un analisis de Clustering.

Diagrama de Codo

Antes de agrupar los datos, necesitamos averiguar cual es la cantidad optima de grupos. Para averiguar este numero, utilizaremos el diagrama de codo del metodo de Ward.

library(factoextra)
library(cluster)

cluster = completeData[,c('Sex','gradeCard1','Height','Weight','Hand grip','UAC1 cm','TST1 mm','SSF1 mm','age')]
cluster$Sex = as.factor(cluster$Sex)
cluster$Sex = as.numeric(cluster$Sex)

set.seed(12)

wss <- (nrow(cluster[,c()])-1)*sum(apply(cluster[,1:ncol(cluster)],2,var))

for (i in 2:10) {
  wss[i] <- sum(kmeans(cluster[,1:ncol(cluster)], centers=i)$withinss)
}
plot(2:
       10, wss[c(2:10)], type="b", xlab="Number of Cluster",  ylab="Squares Summatory", main = "Diagrama de Codo")

Creacion de Cluster

Con ayuda del diagrama de codo, definiremos 4 como la cantidad de clusters a realizar. Utilizaremos la tecnica de k-medias para crear los grupos.

require("fpc")
library(cluster)
set.seed(90)
km = kmeans(cluster, 4)
cluster$grupo<-km$cluster
completeData$grupo = km$cluster

g1 = completeData[cluster$grupo == 1,]
g2 = completeData[cluster$grupo == 2,]
g3 = completeData[cluster$grupo == 3,]
g4 = completeData[cluster$grupo == 4,]

plotcluster(cluster[,c(1:9)],cluster$grupo)

Analisis Express

Ahora que ya tenemos los distintos grupos, hagamos un rapido analisis sobre las distribuciones de cada variable dentro de los grupos

Edad

ggplot(data = completeData, aes(group = grupo, y = age, fill = factor(grupo))) + geom_boxplot(outlier.shape = NA) + xlab("Grupos") + ggtitle("Edad") + ylim(c(0,25))

Podemos ver que esta bastante definido que los grupos estan muy bien definidos conforme a la edad de las personas. Aun asi, notese que en cada grupo la media esta bastante centrada en los boxplots excepto por el primer grupo.

Altura

ggplot(data = completeData, aes(group = grupo, y = Height, fill = factor(grupo))) + geom_boxplot(outlier.shape = NA) + xlab("Grupos") + ggtitle("Altura (cm)") + ylim(c(100,200))

En la altura se ve un comportamiento muy similar con la edad, lo unico curioso es que aqui si se observa que las alturas medias estan bastante centradas dentro de los boxplots.

Peso

ggplot(data = completeData, aes(group = grupo, y = Weight, fill = factor(grupo))) + geom_boxplot(outlier.shape = NA) + xlab("Grupos") + ggtitle("Peso (kg)") + ylim(c(0,100))

En el peso podemos ver el mismo comportamiento analizado anteriormente. Pero a diferencia de la edad y la altura, pareciera que el peso var?a de forma distinta dentro de cada grupos.

Hand grip

ggplot(data = completeData, aes(group = grupo, y = `Hand grip`, fill = factor(grupo))) + geom_boxplot(outlier.shape = NA) + xlab("Grupos") + ggtitle("Hand grip") + ylim(c(0,70))

En la fuerza de la mano tambien tiene el mismo comportamiento que los anteriores, pero se puede ver que el mismo varia mucho mas en el grupo 4, que es el grupo con las personas mas adultas.

Grade

ggplot(data = completeData, aes(group = grupo, y = gradeCard1, fill = factor(grupo))) + geom_boxplot(outlier.shape = NA) + xlab("Grupos") + ggtitle("Grado Escolar")

Nuevamente el patron es notable. La forma del boxplot del primero grupo puede ser debido a que los estudios primarios llegan hasta el numero 16 y los secundarios empiezan en 21. Podria decirse que aqui se encuntran las personas en estudios basicos. En el segundo grupo estan los grados mas peque?os, podriamos llamarlos el primer ciclo primario. En el tercer grupo estan los del segundo ciclo primario y en el cuarto grupo estan los bachilleres.

UAC (circunferencia del tricep)

ggplot(data = completeData, aes(group = grupo, y = `UAC1 cm`, fill = factor(grupo))) + geom_boxplot(outlier.shape = NA) + xlab("Grupos") + ggtitle("UAC1 cm") + ylim(c(10,40))

En la circuferencia de los triceps tambien siguen el patron encontrado, lo cual tiene sentido ya que los musculos tambien crecen conforme la edad.

TST (pliegue cutaneo tricep)

ggplot(data = completeData, aes(group = grupo, y = `TST1 mm`, fill = factor(grupo))) + geom_boxplot(outlier.shape = NA) + xlab("Grupos") + ggtitle("TST1 mm") + ylim(c(0,35))

La variabilidad en el pliege cutaneo de los triceps es muy desigual entre los grupos, y muchos de los grupos comparten similitudes en los datos. Curiosamente estos boxplots no coinciden con los patrones entre grupos encontrados anteriormente.

SSF (pliege cutaneo subescapular)

ggplot(data = completeData, aes(group = grupo, y = `SSF1 mm`, fill = factor(grupo))) + geom_boxplot(outlier.shape = NA) + xlab("Grupos") + ggtitle("SSF1 mm") + ylim(c(0,35))

En el pliegue subescapular pareciera que siguen el patron encontrado anteriormete. Pero el primer grupo y el cuarto son muy similares, aunque la media del primer grupo est? por arriba de la media del cuarto. Sera esto debido a la cantidad de hombres y mujeres dentro del grupo?

Genero

Grupo 1

barplot(prop.table(table(g1$Sex)))

En el grupo 1 hay alrededor de un 20% mas mujeres que hombres.

Grupo 2

barplot(prop.table(table(g2$Sex)))

En el grupo 2 hay alrededor de 10% mas hombres que mujeres.

Grupo 3

barplot(prop.table(table(g3$Sex)))

En el grupo 3 hay alrededor de 20% mas hombres que mujeres.

Grupo 4

barplot(prop.table(table(g4$Sex)))

En el grupo 4, en su mayoria son hombres. Esto podria dar lugar al porque en el grupo 1 se encuentran mas mujeres que hombres.

Altura-Edad

Grupo 1

ggplot(g1, aes(group = age, x = age, y = Height)) +
  geom_boxplot() +
  labs(x = "Edad", y = "Altura (cm)")

Se puede ver que en el grupo 1 el aumento que las alturas mayores sen encuentran entre los 15 y 16 con alturas promedio de 155cm. Esto puede ser debido a la gran cantidad de mujeres presentes en el grupo.

Grupo 2

ggplot(g2, aes(group = age, x = age, y = Height)) +
  geom_boxplot() +
  labs(x = "Edad", y = "Altura (cm)")

En el grupo 2 estan las personas mas jovenes, se puede ver como cambia drasticamente la altura en los ni?os y se empieza a estabilizar a los 10 a?os.

Grupo 3

ggplot(g3, aes(group = age, x = age, y = Height)) +
  geom_boxplot() +
  labs(x = "Edad", y = "Altura (cm)")

En el grupo 3 se puede observar como las personas estan entrando a la adolescencia y empiezan a tener cambios drasticos en la altura entre los 11 y 14 a?os.

Grupo 4

ggplot(g4, aes(group = age, x = age, y = Height)) +
  geom_boxplot() +
  labs(x = "Edad", y = "Altura (cm)")

En el grupo 4 tenemos a las personas mas altas de todo el conjunto de datos.

Hand Grip-Edad

Grupo 1

ggplot(g1, aes(y = `Hand grip`, x = age, group = age)) +
  geom_boxplot() +
  labs(y = "fuerza de agarre (kg)", x = "Edad (anos)")

En el grupo 1, el de los jovenes, se ve que obtienen mas fuerza entre mas crecen, pero la fuerza deja de aumentar considerablemente despues de los 15 a?os, esto puede ser debido a la alta cantidad de mujeres, suponiendo que las mujeres tienen menos fuerza en las manos que los hombres.

Grupo 2

ggplot(g2, aes(y = `Hand grip`, x = age, group = age)) +
  geom_boxplot() +
  labs(y = "fuerza de agarre (kg)", x = "Edad (anos)")

En el grupo 2 estan las personas mas debiles, se puede ver como su fuerza va en promedio de 6 a 12 kg de fuerza de agarre

Grupo 3

ggplot(g3, aes(y = `Hand grip`, x = age, group = age)) +
  geom_boxplot() +
  labs(y = "fuerza de agarre (kg)", x = "Edad (anos)")

En el grupo 3 se ve como las personas van obteniendo mas fuerza conforme crecen y dejan de ser ni?os

Grupo 4

ggplot(g4, aes(y = `Hand grip`, x = age, group = age)) +
  geom_boxplot() +
  labs(y = "fuerza de agarre (kg)", x = "Edad (anos)")

En el grupo 4 se encuentran las personas mas fuertes, mas adultas y en su mayoria hombres. Se puede apreciar tambien las grandes variaciones que se encuentran, lo cual contrasta lo analizado en la exploracion anterior, en la cual se concluyo que en altas edades hay bastantes personas debiles como personas fuertes.

Peso-Edad

Grupo 1

ggplot(g1, aes(group = age, x = age, y = Weight)) +
  geom_boxplot() +
  labs(x = "Edad", y = "Peso (kg)")

En el grupo 1 podemos ver que el promedio de peso cae levemente durante la epoca de pubertad pero se mantiene bastante constante. En lo que se observa cambio es en la variabilidad de los pesos. Los peso promedio esta por los 50 kg.

Grupo 2

ggplot(g2, aes(group = age, x = age, y = Weight)) +
  geom_boxplot() +
  labs(x = "Edad", y = "Peso (kg)")

En el grupo 2 se ve como los ni?os aumentan de peso gradualmente durante su crecimiento. Aqui se encuentran las personas menos pesadas.

Grupo 3

ggplot(g3, aes(group = age, x = age, y = Weight)) +
  geom_boxplot() +
  labs(x = "Edad", y = "Peso (kg)")

En el grupo 3 puede verse que estan las personas mas pesadas de 5, 6 y 7 a?os, edades que tambien estan presente en el grupo 2. Luego se puede apreciar como las personas siguen aumentando de peso conforme van creciendo.

Grupo 4

ggplot(g4, aes(group = age, x = age, y = Weight)) +
  geom_boxplot() +
  labs(x = "Edad", y = "Peso (kg)")

En el grupo 4 estan las personas mas pesadas de todas. desde ni?os hasta adultos.

Conclusion de Cluster

La edad es una medida critica para entrar o no a los grupos.
Si eres un niño con peso y altura de un joven, el clustering te agrupa a ellos y viceversa.
El grupo 1 es el unico grupo con mas mujeres.
En el grupo 4 hay hombres en su mayoria.
Los pliegues cutaneos varian de distintas maneras dentro de los grupos y no existe una diferencia representante entre el grupo 1 y 4.

Prediciendo Peso

RLM

Matriz de Correlacion

Antes de realizar un modelo linal multiple, hay que ver como se relacionan las variables entre ellas.

 datos = completeData
 datos$Sex = as.factor(datos$Sex)
 datos$Sex = as.numeric(datos$Sex)

 
 #Obtener matriz de correlacion
 cormat = round(cor(datos,use = "complete.obs"),2)
 #Reordenar matriz de correlacion
 reorder_cormat <- function(cormat){
 # Use correlation between variables as distance
 dd <- as.dist((1-cormat)/2)
 hc <- hclust(dd)
 cormat <-cormat[hc$order, hc$order]
 }
 cormat = reorder_cormat(cormat)
 #Obtener triangulo superior
 get_upper_tri = function(cormat){
   cormat[lower.tri(cormat)] = NA
   return(cormat)
 }
 upper_tri = get_upper_tri(cormat)
 #Correlacion como heatmap
 require(reshape2)

## Loading required package: reshape2

## 
## Attaching package: 'reshape2'

## The following objects are masked from 'package:data.table':
## 
##     dcast, melt

 melted_cormat = melt(upper_tri, na.rm = T)
 require(ggplot2)
 ggheatmap = ggplot(data = melted_cormat, aes(x=Var1, y=Var2, fill = value)) + geom_tile(color = "white") + scale_fill_gradient2(low = "blue",high = "red",mid = "white", midpoint = 0, limit = c(-1,1), space = "Lab", name="Correlacion") + theme_minimal() + theme(axis.text.x = element_text(angle = 90, vjust = 1,hjust = 1)) + coord_fixed()
 
 ggheatmap + 
 geom_text(aes(Var2, Var1, label = value), color = "black", size = 4) +
 theme(
   axis.title.x = element_blank(),
   axis.title.y = element_blank(),
   panel.grid.major = element_blank(),
   panel.border = element_blank(),
   panel.background = element_blank(),
   axis.ticks = element_blank(),
   legend.justification = c(1, 0),
   legend.position = c(0.6, 0.7),
   legend.direction = "horizontal")+
   guides(fill = guide_colorbar(barwidth = 7, barheight = 1,
                 title.position = "top", title.hjust = 0.5))

Se puede ver que nuestras variables fisicas de los individuos se relacionan bastante bien. Las variables en las cuales no se nota una relacion con cualquier otra son sex y school. Eliminemoslas y corramos el mismo analisis.

 datos$grade <- datos$gradeCard1
 datos$gradeCard1 <- NULL
 datos$`grade Card 2` <- NULL
 datos$height <- datos$Height
 datos$weight <- datos$Weight
 datos$Height <- NULL
 datos$Weight <- NULL
 datos$hand_grip <- datos$`Hand grip`
 datos$`Hand grip` <- NULL
 datos$UAC <- datos$`UAC1 cm`
 datos$`UAC1 cm` <- NULL
 datos$`UAC2 cm` <- NULL
 datos$TST <- datos$`TST1 mm`
 datos$`TST1 mm` <- NULL
 datos$`TST2 mm` <- NULL
 datos$SSF <- datos$`SSF1 mm`
 datos$`SSF1 mm` <- NULL
 datos$`SSF2 mm` <- NULL
 
 data_NN <- datos
 datos = datos[,c("grade","height","weight","hand_grip","UAC","TST","SSF","age")]

 
 #Obtener matriz de correlacion
 cormat = round(cor(datos,use = "complete.obs"),2)
 #Reordenar matriz de correlacion
 reorder_cormat <- function(cormat){
 # Use correlation between variables as distance
 dd <- as.dist((1-cormat)/2)
 hc <- hclust(dd)
 cormat <-cormat[hc$order, hc$order]
 }
 cormat = reorder_cormat(cormat)
 #Obtener triangulo superior
 get_upper_tri = function(cormat){
   cormat[lower.tri(cormat)] = NA
   return(cormat)
 }
 upper_tri = get_upper_tri(cormat)
 #Correlacion como heatmap
 require(reshape2)
 melted_cormat = melt(upper_tri, na.rm = T)
 require(ggplot2)
 ggheatmap = ggplot(data = melted_cormat, aes(x=Var1, y=Var2, fill = value)) + geom_tile(color = "white") + scale_fill_gradient2(low = "blue",high = "red",mid = "white", midpoint = 0, limit = c(-1,1), space = "Lab", name="Correlacion") + theme_minimal() + theme(axis.text.x = element_text(angle = 90, vjust = 1,hjust = 1)) + coord_fixed()
 
 ggheatmap + 
 geom_text(aes(Var2, Var1, label = value), color = "black", size = 4) +
 theme(
   axis.title.x = element_blank(),
   axis.title.y = element_blank(),
   panel.grid.major = element_blank(),
   panel.border = element_blank(),
   panel.background = element_blank(),
   axis.ticks = element_blank(),
   legend.justification = c(1, 0),
   legend.position = c(0.6, 0.7),
   legend.direction = "horizontal")+
   guides(fill = guide_colorbar(barwidth = 7, barheight = 1,
                 title.position = "top", title.hjust = 0.5))

Ahora removeremos las variables independientes que se relaciones entre ellas para evitar la multicolinearidad. Entre hand_grip y height hay una relacion del 89%. Debido a que la ultura y el peso pueden tomarse como co-variables se removera height.
Entre age y grade hay una alta y obvia relacion del 91%, nos quedaremos con age ya que tiene una mayor relacion con weight.
Entre TST Y SSF existe una relacion del 82%, se escogera a SSF para el modelo por su mayor relacion con weight.

 datos = datos[,c("weight","hand_grip","UAC","SSF","age")]

 
 #Obtener matriz de correlacion
 cormat = round(cor(datos,use = "complete.obs"),2)
 #Reordenar matriz de correlacion
 reorder_cormat <- function(cormat){
 # Use correlation between variables as distance
 dd <- as.dist((1-cormat)/2)
 hc <- hclust(dd)
 cormat <-cormat[hc$order, hc$order]
 }
 cormat = reorder_cormat(cormat)
 #Obtener triangulo superior
 get_upper_tri = function(cormat){
   cormat[lower.tri(cormat)] = NA
   return(cormat)
 }
 upper_tri = get_upper_tri(cormat)
 #Correlacion como heatmap
 require(reshape2)
 melted_cormat = melt(upper_tri, na.rm = T)
 require(ggplot2)
 ggheatmap = ggplot(data = melted_cormat, aes(x=Var1, y=Var2, fill = value)) + geom_tile(color = "white") + scale_fill_gradient2(low = "blue",high = "red",mid = "white", midpoint = 0, limit = c(-1,1), space = "Lab", name="Correlacion") + theme_minimal() + theme(axis.text.x = element_text(angle = 90, vjust = 1,hjust = 1)) + coord_fixed()
 
 ggheatmap + 
 geom_text(aes(Var2, Var1, label = value), color = "black", size = 4) +
 theme(
   axis.title.x = element_blank(),
   axis.title.y = element_blank(),
   panel.grid.major = element_blank(),
   panel.border = element_blank(),
   panel.background = element_blank(),
   axis.ticks = element_blank(),
   legend.justification = c(1, 0),
   legend.position = c(0.6, 0.7),
   legend.direction = "horizontal")+
   guides(fill = guide_colorbar(barwidth = 7, barheight = 1,
                 title.position = "top", title.hjust = 0.5))

Modelo

Para realizar el modelo, utilizaremos una muestra aleatoria del 70% de los datos para entrenar el modelo y utilizaremos el 30% restante para probarlo.

set.seed(12)

RLMmodel = lm(weight~., data = datos)

summary(RLMmodel)

## 
## Call:
## lm(formula = weight ~ ., data = datos)
## 
## Residuals:
##    Min     1Q Median     3Q    Max 
## -52.30  -2.42  -0.23   2.13  48.95 
## 
## Coefficients:
##             Estimate Std. Error t value Pr(>|t|)    
## (Intercept) -0.13357    0.07809   -1.71    0.087 .  
## hand_grip    0.74590    0.00243  307.03   <2e-16 ***
## UAC          0.24055    0.00394   61.05   <2e-16 ***
## SSF          0.77729    0.00272  285.87   <2e-16 ***
## age          0.94117    0.00786  119.73   <2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 4.31 on 91753 degrees of freedom
## Multiple R-squared:  0.917,  Adjusted R-squared:  0.917 
## F-statistic: 2.53e+05 on 4 and 91753 DF,  p-value: <2e-16

Se puede ver que ahora todas las variables aportan significativamente al modelo. El siguiente paso es realizr un analisis de residuos para validar el modelo.

Analisis de Residuos

Para validar el modelo se deben cumplir los supuestos de independencia, normalidad y varianza constante del error.

Normalidad del Error

par(mfrow=c(1,1))
plot(RLMmodel, which = 2)

hist(RLMmodel$residuals, col = 'cyan', xlab = "Histograma de los Residuos")

En el grafico QQ se puede ver que los residuos no siguen la linea del error por lo que el supuesto de la normalidad no se cumple. De la misma manera, en el histograma del error se nota una forma de campana, pero no esta centrada por lo que no se cumple la normalidad.

Varianza constante e independencia

plot(RLMmodel, which = 1)

En cuanto a la independencia, se puede ver como los residuos se colocan aleatoriamente por arriba y por debajo del 0 comprobando su independencia. Por otro lado, se puede ver que los residuos van creciendo por lo que no existe constancia.

Conclusión

El modelo es preciso en los cuartiles centrales. No se cumplen todos los supuestos por lo que no se puede validar el modelo.
Si se remueven los datos atipicos, el modelo podria ser validado.

Regrision Logaritmica

Debido a que puede que no todas las variables seleccionadas sigan una distribucion normal, comprobaremos cuales de estas son normales utilizando una prueba de Kolmogorov-Smirnov. La hipotesis nula de esta prueba indica que la variable sigue la distribucion indicada (en este caso, la normal).

require(MASS)

## Loading required package: MASS

## 
## Attaching package: 'MASS'

## The following object is masked from 'package:dplyr':
## 
##     select

require(car)

## Loading required package: car

## Loading required package: carData

## 
## Attaching package: 'car'

## The following object is masked from 'package:psych':
## 
##     logit

## The following object is masked from 'package:dplyr':
## 
##     recode

ks.test(datos$weight, "pnorm", mean(datos$weight), sd(datos$weight))

## Warning in ks.test(datos$weight, "pnorm", mean(datos$weight),
## sd(datos$weight)): ties should not be present for the Kolmogorov-Smirnov
## test

## 
##  One-sample Kolmogorov-Smirnov test
## 
## data:  datos$weight
## D = 0.105, p-value <2e-16
## alternative hypothesis: two-sided

ks.test(datos$hand_grip, "pnorm", mean(datos$hand_grip), sd(datos$hand_grip))

## Warning in ks.test(datos$hand_grip, "pnorm", mean(datos$hand_grip),
## sd(datos$hand_grip)): ties should not be present for the Kolmogorov-Smirnov
## test

## 
##  One-sample Kolmogorov-Smirnov test
## 
## data:  datos$hand_grip
## D = 0.12, p-value <2e-16
## alternative hypothesis: two-sided

ks.test(datos$UAC, "pnorm", mean(datos$UAC), sd(datos$UAC))

## Warning in ks.test(datos$UAC, "pnorm", mean(datos$UAC), sd(datos$UAC)):
## ties should not be present for the Kolmogorov-Smirnov test

## 
##  One-sample Kolmogorov-Smirnov test
## 
## data:  datos$UAC
## D = 0.117, p-value <2e-16
## alternative hypothesis: two-sided

ks.test(datos$SSF, "pnorm", mean(datos$SSF), sd(datos$SSF))

## Warning in ks.test(datos$SSF, "pnorm", mean(datos$SSF), sd(datos$SSF)):
## ties should not be present for the Kolmogorov-Smirnov test

## 
##  One-sample Kolmogorov-Smirnov test
## 
## data:  datos$SSF
## D = 0.173, p-value <2e-16
## alternative hypothesis: two-sided

ks.test(datos$age, "pnorm", mean(datos$age), sd(datos$age))

## Warning in ks.test(datos$age, "pnorm", mean(datos$age), sd(datos$age)):
## ties should not be present for the Kolmogorov-Smirnov test

## 
##  One-sample Kolmogorov-Smirnov test
## 
## data:  datos$age
## D = 0.117, p-value <2e-16
## alternative hypothesis: two-sided

En todos los casos se rechaza la hipotesis nula, por lo que ninguna variable sigue una distribución normal. Con graficas trataremos de determinar algun tipo de distribucion.

par(mfrow=c(1,2))

hist(datos$weight, main="Histograma Peso")
plot(density(datos$weight), main="Densidad Peso")

hist(datos$hand_grip, main="Histograma Fuerza de agarre")
plot(density(datos$hand_grip), main="Densidad Fuerza de agarre")

hist(datos$UAC, main="Histograma UAC")
plot(density(datos$UAC), main="Densidad UAC")

hist(datos$SSF, main="Histograma SSF")
plot(density(datos$SSF), main="Densidad SSF")

hist(datos$age, main = "Histograma Edad")
plot(density(datos$age), main = "Densidad Edad")

Las variables peso, fuerza de agarre y SSF (pliegues subcutaneos de piel) parecen seguir una distribucion logaritmica, por lo que una transformacion a una distribucion log-normal parece adecuada. La variable UAC parece ser logarítmica, con un grupo de datos atípicos en 0. La edad no parece tener una distribucion clara (¿tal vez uniforme?). Estos datos no tienen sentido, debido a que es imposible tener circunferencia cero del triceps. Se eliminarán estos datos.

datos <- datos %>% 
  filter(UAC > 0)

hist(datos$UAC, main="Histograma UAC")

plot(density(datos$UAC), main="Densidad UAC")

Esto tiene mucho mas sentido y parece mas a una ditribucion logaritmica.

Ahora, utilizaremos la prueba de Kolmogorov-Smirnov para determinar si la transformacion de estas variables sigue una distribucion normal. Por pura curiosidad, convertiremos la variable edad tambien.

ks.test(log(datos$weight), mean(log(datos$weight)), sd(log(datos$weight)))

## Warning in ks.test(log(datos$weight), mean(log(datos$weight)),
## sd(log(datos$weight))): p-value will be approximate in the presence of ties

## 
##  Two-sample Kolmogorov-Smirnov test
## 
## data:  log(datos$weight) and mean(log(datos$weight))
## D = 0.522, p-value = 0.95
## alternative hypothesis: two-sided

ks.test(log(datos$hand_grip), mean(log(datos$hand_grip)), sd(log(datos$hand_grip)))

## Warning in ks.test(log(datos$hand_grip), mean(log(datos$hand_grip)),
## sd(log(datos$hand_grip))): p-value will be approximate in the presence of
## ties

## 
##  Two-sample Kolmogorov-Smirnov test
## 
## data:  log(datos$hand_grip) and mean(log(datos$hand_grip))
## D = 1, p-value = 0.27
## alternative hypothesis: two-sided

ks.test(log(datos$UAC), mean(log(datos$UAC)), sd(log(datos$UAC)))

## Warning in ks.test(log(datos$UAC), mean(log(datos$UAC)),
## sd(log(datos$UAC))): p-value will be approximate in the presence of ties

## 
##  Two-sample Kolmogorov-Smirnov test
## 
## data:  log(datos$UAC) and mean(log(datos$UAC))
## D = 0.545, p-value = 0.93
## alternative hypothesis: two-sided

ks.test(log(datos$SSF), mean(log(datos$SSF)), sd(log(datos$SSF)))

## Warning in ks.test(log(datos$SSF), mean(log(datos$SSF)),
## sd(log(datos$SSF))): p-value will be approximate in the presence of ties

## 
##  Two-sample Kolmogorov-Smirnov test
## 
## data:  log(datos$SSF) and mean(log(datos$SSF))
## D = 1, p-value = 0.27
## alternative hypothesis: two-sided

ks.test(log(datos$age), mean(log(datos$age)), sd(log(datos$age)))

## Warning in ks.test(log(datos$age), mean(log(datos$age)),
## sd(log(datos$age))): p-value will be approximate in the presence of ties

## 
##  Two-sample Kolmogorov-Smirnov test
## 
## data:  log(datos$age) and mean(log(datos$age))
## D = 0.534, p-value = 0.94
## alternative hypothesis: two-sided

Ninguna prueba rechaza la hipotesis nula, por lo que parece que se logro normalizar los datos al aplicar una tranformacion logaritmica.

hist(datos$weight, main="Histograma log Peso")

plot(density(datos$weight), main="Densidad log Peso")

hist(log(datos$hand_grip), main="Histograma log Fuerza de agarre")

plot(density(log(datos$hand_grip)), main="Densidad log Fuerza de agarre")

hist(log(datos$UAC), main="Histograma log UAC")

plot(density(log(datos$UAC)), main="Densidad log UAC")

hist(log(datos$SSF), main="Histograma log SSF")

plot(density(log(datos$SSF)), main="Densidad log SSF")

hist(log(datos$age), main = "Histograma log Edad")

plot(density(log(datos$age)), main = "Densidad log Edad")

Todos las variables, exceptuando la edad parecen haberse normalizado despues de la transformacion. Por lo tanto, aplicaremos la tranformacion logaritmica a todas las variables y probaremos también con la edad debido a que la prueba no rechazo la distribucion.

Tranformacion de los datos y remocion de valores “infinitos”:

log.datos <- log(datos)
log.datos <- log.datos[!is.infinite(rowSums(log.datos)),]

Muestreo del 70% de los datos para la construccion del modelo y 30% para probar la precision del mismo.

set.seed(123)

muestra <- sample(nrow(log.datos),nrow(log.datos)*.7)

log.train <- log.datos[muestra,]
log.test <- log.datos[-muestra,]

Construccion del modelo y resumen del mismo:

log.model <- lm(weight~hand_grip + UAC + SSF + age, data = log.train)
summary(log.model)

## 
## Call:
## lm(formula = weight ~ hand_grip + UAC + SSF + age, data = log.train)
## 
## Residuals:
##     Min      1Q  Median      3Q     Max 
## -0.9840 -0.0553 -0.0007  0.0552  1.1738 
## 
## Coefficients:
##             Estimate Std. Error t value Pr(>|t|)    
## (Intercept) -1.04981    0.01206   -87.0   <2e-16 ***
## hand_grip    0.18410    0.00158   116.5   <2e-16 ***
## UAC          1.05406    0.00521   202.1   <2e-16 ***
## SSF          0.08057    0.00106    76.1   <2e-16 ***
## age          0.29379    0.00228   128.6   <2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 0.0882 on 62724 degrees of freedom
## Multiple R-squared:  0.949,  Adjusted R-squared:  0.949 
## F-statistic: 2.91e+05 on 4 and 62724 DF,  p-value: <2e-16

Todas las variables parecen ser altamente significativas para predecir el logaritmo natural del peso. El modelo es significativo (p < 0.00001) y posee un R cuadrado de 0.949.

Comprobacion de los supuestos:

plot(log.model, which = 1)

Los datos son homocedasticos (la varianza es constante).

vif(log.model)

## hand_grip       UAC       SSF       age 
##    6.4652    6.5481    2.7844    3.8677

El factor de inflacion de varianza de las variables “fuerza de agarre” y “circunferencia del triceps” es mayor a 5, por lo que los datos sufren de multicolinealidad.

plot(log.model, which = 2)

El grafico normal Q-Q sigue la linea recta en el la parte central, pero tiene colas muy marcadas en los extremos, por lo que probablemente existen mas valores extremos que los que se esperarian de una distribucion normal.

Dos de los supuestos de la normalidad de los datos y el modelo no se cumplen. Debido a esto el modelo no es adecuado para predecir estos datos.

Red Neuronal

El siguiente modelo que se verificara sera una red neuronal utilizando Caret. Para este se utilizaran todas las variables resultantes del analisis de componenetes principales en donde se reducen variables de ambos lados del cuerpo a una sola.

Creando los sets de prueba y evaulacion

Primero se crean los sets de datos de prueba y evaluacion haciendo un muestreo aleatorio de la base de datos

porcentaje<-0.7

set.seed(098769)

corte <- sample(nrow(data_NN),nrow(data_NN)*porcentaje)
data_NN$Id <- NULL
data_NN$`IdSchool 1` <- NULL
data_NN$date <- NULL
data_NN$grupo <- NULL
data_NN$Sex <- NULL
data_NN <- scale(data_NN)
data_NN <- as.data.frame(data_NN)
train<-data_NN[corte,]

test<-data_NN[-corte,]

Crear el modelo

modeloCaret <- train(weight~., data=train, method="nnet", trace=F,linout = TRUE)

test$prediccionCaret<-as.numeric(predict(modeloCaret, newdata = test))

rsq <- function (x, y) cor(x, y) ^ 2

weightR2 <- rsq(test$weight, test$prediccionCaret)
weightR2

## [1] 0.97125

Se creo el modelo en la primera iteración con las variables no normalizadas. Esto produjo un R-cuadrado de **0.75**. El siguiente modelo que se probó, se utilizó con las variables normalizadas, como sugieren que se realicen los modelos de predicción de redes neuronales. Este modelo obtuvo muchos mejores resultados que el modelo anterior y como se puede observar se obtuvo un `R-cuadrado de 0.97.

Conclusiones

El modelo es preciso en un 97% por lo que se puede utilizar correctamente para predicciones. Preferiblemente sin realizar extrapolaciones a grupos etarios mucho mayores ya que se está trabajando con datos de niños, si se quiere hacer predicciones para adultos se requiere información de adultos.
Se recomienda utilizar un modelo de redes neuronales por encima del modelo de regresión lineal ya que este parece tener una mejor precisión y no es necesario validar supuestos, que fue el paso en donde el modelo de regresión lineal falló.

Proyecto 2

Oliver Mazariegos, Rafael Leon y Alejandro Vasquez

18/8/2018

Situacion Problematica

Problema Cientifico

Objetivos

General

Específicos

Conjunto de datos

Leyendo Datos

Variables desechadas

Subject

Card1

Card2

Union y Limpieza de Datos

Subject-Card1-Card2

Analisis Exploratorio

Exploraci?n de variables y eliminacion de outlier

Frecuencia de edades

Altura por Edad

Sin outliers

Pesos por Edades

Sin outliers

Regresion Lineal Peso-Altura

Altura-Dientes

IdSchool | Repetition | RepetitionCard1

Fuerza de Agarre (Hand grip)

Sin outliers

Fuerza de Agarre-Edad

Desecho de Variables

Analis?s de Componentes Principales

Matriz de Correlaci?n

Cluster

Diagrama de Codo

Creacion de Cluster

Analisis Express

Edad

Altura

Peso

Hand grip

Grade

UAC (circunferencia del tricep)

TST (pliegue cutaneo tricep)

SSF (pliege cutaneo subescapular)

Genero

Grupo 1

Grupo 2

Grupo 3

Grupo 4

Altura-Edad

Grupo 1

Grupo 2

Grupo 3

Grupo 4

Hand Grip-Edad

Grupo 1

Grupo 2

Grupo 3

Grupo 4

Peso-Edad

Grupo 1

Grupo 2

Grupo 3

Grupo 4

Conclusion de Cluster

Prediciendo Peso

RLM

Matriz de Correlacion

Modelo

Analisis de Residuos

Normalidad del Error

Varianza constante e independencia

Conclusión

Regrision Logaritmica

Red Neuronal

Creando los sets de prueba y evaulacion

Crear el modelo

Conclusiones